home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Pascal / Snippets / SlotVBL 1.0 / MySlotVBL.p next >
Encoding:
Text File  |  1996-05-11  |  3.8 KB  |  174 lines  |  [TEXT/PJMM]
  1. {A VBL synching unit for SAT or general use alike.}
  2.  
  3. {Based on SlotVInstall.p from DTS, but significantly enhanced; works without Color QD}
  4. {and is a reusable unit.}
  5. {}
  6. {By Ingemar Ragnemalm 1996.}
  7. {}
  8. {Note: Works with both 68k and PPC.}
  9.  
  10. unit MySlotVBL;
  11.  
  12. interface
  13.     uses
  14. {$IFC UNDEFINED THINK_PASCAL}
  15.         Types, Devices, QuickDraw, OSUtils, 
  16. {$ELSEC}
  17. {$SETC GENERATINGPOWERPC := FALSE}
  18. {$ENDC}
  19.         Retrace;
  20.  
  21.     function InstallVBL (myGDevHand: GDHandle): OSErr;
  22.     procedure RemoveVBL;
  23.  
  24.     function GetVBLValue: Longint;
  25.     procedure SetVBLValue (value: Longint);
  26.  
  27. {To synch SAT by VBL, install SATSynch as synch procedure.}
  28. {CAUTION: InstallVBL must have succeeded, or SATSynch will wait forever!}
  29. {Also, don't forget a RemoveVBL when you quit!}
  30.     function SATSynch: Boolean;
  31.  
  32. implementation
  33.  
  34.     const
  35.         kVBLCount = 1;
  36.  
  37.     type
  38.         EnhVBLTask = record
  39.                 theVBLTask: VBLTask;
  40.                 theGlobal: ^LongInt;
  41.             end;
  42.         EnhVBLTaskPtr = ^EnhVBLTask;
  43.  
  44.     var
  45.         myVBLTask: EnhVBLTask;
  46.         gLong: Longint;
  47.         installed, installedColor: Boolean;
  48.  
  49.     function GetVBLValue: Longint;
  50.     begin
  51.         GetVBLValue := gLong; {myVBLTask.theGlobal;}
  52.     end; {GetVBLValue}
  53.  
  54.     procedure SetVBLValue (value: Longint);
  55.     begin
  56. {myVBLTask.theGlobal := }
  57.         gLong := value;
  58.     end; {SetVBLValue}
  59.  
  60. {$PUSH}
  61. {$D-}
  62.  
  63. {$IFC GENERATINGPOWERPC}
  64.  
  65.     procedure MyVBLProc (theEnhVBLTaskRecPtr: EnhVBLTaskPtr);
  66.     begin
  67.         theEnhVBLTaskRecPtr^.theGlobal^ := theEnhVBLTaskRecPtr^.theGlobal^ + 1;
  68.         { reset VBL }
  69.         theEnhVBLTaskRecPtr^.theVBLTask.vblCount := kVBLCount;
  70.     end; {MyVBLProc, PPC}
  71.  
  72. {$ELSEC}
  73.     function GetVBLRec: EnhVBLTaskPtr;
  74.     inline
  75.         $2E88; { put A0 on stack }
  76.  
  77.     procedure MyVBLProc;
  78.         var
  79.             theEnhVBLTaskRecPtr: EnhVBLTaskPtr;
  80.     begin
  81.         theEnhVBLTaskRecPtr := GetVBLRec;
  82.  
  83.         theEnhVBLTaskRecPtr^.theGlobal^ := theEnhVBLTaskRecPtr^.theGlobal^ + 1;
  84.         { reset VBL }
  85.         theEnhVBLTaskRecPtr^.theVBLTask.vblCount := kVBLCount;
  86.     end; {MyVBLProc, 68k}
  87. {$ENDC}
  88.  
  89. {$POP}
  90.  
  91.     var
  92.         myDCEHand: AuxDCEHandle;        {Kept for SlotVRemove!}
  93.  
  94.     function HasColor: Boolean;
  95.         var
  96.             theWorld: SysEnvRec;
  97.     begin
  98.         HasColor := false;
  99.         if SysEnvirons(1, theWorld) = noErr then
  100.             HasColor := theWorld.hasColorQD;
  101.     end; {HasColor}
  102.  
  103.     function InstallVBL (myGDevHand: GDHandle): OSErr;
  104.         var
  105.             mainGDRefNum: INTEGER;
  106.             vblGlobalLongInt, tempLongInt: LONGINT;
  107.             retCode: OSErr;
  108.     begin
  109.         if installed then
  110.             begin
  111.                 InstallVBL := -1;        {Already installed}
  112.                 Exit(InstallVBL);
  113.             end;
  114.  
  115. {If no device is provided, use the main device as default!}
  116.         if myGDevHand = nil then
  117.             if HasColor then
  118.                 myGDevHand := GetMainDevice;
  119.  
  120.         if HasColor and (myGDevHand <> nil) then
  121.             begin
  122.                 mainGDRefNum := myGDevHand^^.gdRefNum;
  123.                 myDCEHand := AuxDCEHandle(GetDctlEntry(mainGDRefNum));
  124.                 installedColor := true;
  125.             end
  126.         else
  127.             installedColor := false;
  128.  
  129.     { set up VBL task }
  130.         myVBLTask.theVBLTask.qType := ORD(vType);
  131. {$IFC UNDEFINED THINK_PASCAL}
  132.         myVBLTask.theVBLTask.vblAddr := NewVBLProc(@MyVBLProc);
  133. {$ELSEC}
  134.         myVBLTask.theVBLTask.vblAddr := @MyVBLProc;
  135. {$ENDC}
  136.         myVBLTask.theVBLTask.vblCount := kVBLCount;
  137.         myVBLTask.theVBLTask.vblPhase := 0;
  138.         myVBLTask.theGlobal := @gLong;
  139.  
  140.         vblGlobalLongInt := 0;
  141.         tempLongInt := 0;
  142.  
  143.         if installedColor then
  144.             retCode := SlotVInstall(@myVBLTask, myDCEHand^^.dCtlSlot)
  145.         else
  146.             retCode := VInstall(@myVBLTask);
  147.         InstallVBL := retCode;
  148.  
  149.         installed := retCode = noErr;
  150.     end; {InstallVBL}
  151.  
  152.     procedure RemoveVBL;
  153.         var
  154.             retCode: OSErr;
  155.     begin
  156.         if installed then
  157.             if installedColor then
  158.                 retCode := SlotVRemove(@myVBLTask, myDCEHand^^.dCtlSlot)
  159.             else
  160.                 retCode := VRemove(@myVBLTask);
  161. {I don't return the error code. I mean, what can be done about it?}
  162.         installed := false;
  163.     end; { ELSE }
  164.  
  165. {A standard synch proc for SAT:}
  166.     function SATSynch: Boolean;
  167.     begin
  168.         gLong := 0;                {or SetVBLValue(0);}
  169.         while gLong = 0 do        {or GetVBLValue = 0}
  170.             ;
  171.         SATSynch := false;        {Always return false!}
  172.     end; {SATSynch}
  173.  
  174. end.